00100	C ***** SCANNER *************************  
00200	C**** SCANR,BGSORT,FMT,RANR,SQYY,COLTTY,READER,CLEAN   7/74
00300		SUBROUTINE SCANR
00400		DIMENSION IP(30)
00500		COMMON P(30),J,L,CNT(27),BT,PL(48),MK,DF,DUR(27)
00600		1 ,IQ(27),ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,ISUB,NFLG,IXX,ISEMI,IQT
00700		1 ,INP(144),VX(70),ISCA(12),IDAT(11),IAMP,K,KN,M,ML,CODE,IBLA
00800		EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
00900		1 ,(IEN,ISCA(4)),(IP,PL)
01000	C 2/74 IP IS NOW EQUIV TO PL!  USED TO BE IP WITH P.(HURT 'TAP' ROUTINE.)
01100	C  WILL THIS DO ANYTHING TO MUSIC5 VERSION??
01200	      NNUM=-1     
01300	      ISKP=0
01400	      JJ=0  
01500		XMINUS=1.    
01600	999      IDECI=-1  
01700	      M=0   
01800	2799	N=INP(ML)
01900		IF(N.NE.IQT)GO TO 899
02000		JA=-1
02100		ML=ML+1
02200		ISUB=8
02300		JJ=JJ+1
02400		VX(JJ)=ML
02500	C  POINTS TO FIRST LIT. CHAR.
02600		DO 1177 K=ML,144
02700		IF(INP(K).NE.IQT)GO TO 1177
02800		ML=K+1
02900	2177	N=INP(ML)
03000		GO TO 899
03100	1177	CONTINUE
03200	C  SKIPS 'LIT' ITEMS IN RAN. SELECTION
03300	899   ML=ML+1
03400		IF(N.EQ.ISEMI)GO TO 751
03500		IF(N.NE.IBLA)GO TO 510
03600	4702      IF(ISKP)202,2799,2799
03700	
03800	510	IF(JA)GO TO 70
03900	C********** MAY 22,71
04000	      DO 77 K=1,12   
04100	      IF(N.NE.ISCA(K))GO TO 77
04200		IF(K.NE.2.AND.K.NE.4)GO TO 511
04300		NSWCH=K-4
04400		GO TO 2177
04500	C  TO SWITCH ALWAYS USE OCT.#  /PBF4/  /OE5/  P=PROXIMITY, O=ORDINARY
04600	C ************ MAY 22,71
04700	511   NNUM=K
04800		JJ=JJ+1
04900		NFLG=-1
05000		N=INP(ML)
05100		IF(N.NE.IF)GO TO 410
05200		NNUM=NNUM-1
05300		GO TO 610
05400	410	IF(N.NE.ISS)GO TO 3410
05500		NNUM=NNUM+1
05600	610	ML=ML+1
05700		N=INP(ML)
05800	3410	IF(N.NE.IEN.AND.N.NE.'I')GO TO 371
05900	C  'END' OR 'FINE' WILL END INST.
06000	C******** MAY 20,71
06100	3411	VX(JJ)=10000.
06200		IF(DUR(LK))DUR(LK)=1000.
06300		IAMP=-1
06400		RETURN
06500	371	IF(N.EQ.ISEMI.OR.N.EQ.IBLA)GO TO 5410
06600		DO 177 KN=2,8
06700		IF(N.NE.IDAT(KN))GO TO 177
06800		JSCA=KN-2
06900		ML=ML+1
07000		GO TO 2410
07100	177	CONTINUE
07200		GO TO 6410
07300	5410	KN=-1
07400	6410	IF(NSWCH.EQ.0)GO TO 2410
07500		IF(KN)GO TO 7410
07600	CC	IF(N.EQ.'+')NOLD=NOLD+6
07700	CC	IF(N.EQ.'-')NOLD=NOLD-6
07800	C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
07900	7410	IF(NOLD-NNUM.GT.5.AND.JSCA.LT.7)JSCA=JSCA+1
08000		IF(NOLD-NNUM.LT.-5.AND.JSCA.GT.0)JSCA=JSCA-1
08100	C   WILL JUMP TO NEAREST NOTE ***********  MAY 22,71
08200	2410	VX(JJ)=JSCA*12+NNUM
08300		NOLD=NNUM
08400	C ********** MAY 22,71
08500	4410	NNUM=-2
08600		IF(INP(ML).EQ.ISEMI)RETURN
08700	C   ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
08800		IF(N.EQ.IXX)GO TO 210
08900		GO TO 310
09000	C *********MAY 22,71
09100	77    CONTINUE    
09200	70    IF(N.NE.'-')GO TO 71   
09300	      XMINUS=-1.   
09400	      GO TO 2799   
09500	210	JJ=JJ+1
09600		IF(JJ.EQ.1)GO TO 3310
09700	C****** MAY 19,71
09800		XMINUS=1.
09900		VX(JJ)=0
10000	C  'X N1,N2' MAY REPLACE 'REP N1,N2'.  N2=0 BECOMES N2=2
10100		GO TO 310
10200	71	IF(N.EQ.IXX)GO TO 210
10300		IF(N.EQ.'R')GO TO 73     
10400	
10500	1410  DO 78 K=1,11
10600	      IF(N.NE.IDAT(K))GO TO 78
10700		ISKP=-1
10800		IF(N.NE.IDOT)GO TO 79
10900		IDECI=M
11000		GO TO 75
11100	79    M=M+1 
11200	      IP(M)=K-1   
11300		GO TO 75
11400	78	CONTINUE
11500		IF(N.NE.IE.AND.N.NE.IF)GO TO 781
11600	C  'END' OR 'FINE' WILL END INST.
11700		JJ=1
11800		GO TO 3411
11900	781	IF(N.EQ.'/')N=ISEMI
12000	C   FOR MOTIVIC TRANFORMATIONS
12100	
12200	75	IF(INP(ML).EQ.IXX)GO TO 202
12300	C  FOR 2X3, ETC.    CHECK THIS OUT.  6/74
12400	CC75	IF(INP(ML).NE.IXX)GO TO 752
12500	CC	ML=ML-1
12600	CC	GO TO 202
12700	C  FOR 'X' WITHOUT SPACES.
12800	752	IF(N.NE.ISEMI.AND.INP(ML).NE.1)GO TO 2799
12900	751	IF(ISKP.EQ.0)RETURN
13000	202   IF(IDECI.NE.-1)GO TO 302    
13100	      IDECI=0     
13200	      GO TO 402   
13300	302   IDECI=M-IDECI     
13400	402   KN=0  
13500	      IEXP=M-1    
13600	      IF(M.LT.1)M=1     
13700	      DO 171 K=1,M
13800		KV=10**IEXP
13900		IF(IEXP.EQ.0)KV=1
14000	      KN=KN+IP(K)*KV 
14100	171     IEXP=IEXP-1     
14200	      A=10**IDECI 
14300		IF(IDECI.EQ.0)A=1.
14400		JJ=JJ+1
14500		VX(JJ)=KN/A*XMINUS
14600		IF(ISUB.EQ.1)RETURN
14700		IF(CODE.NE.-22.)XMINUS=1.
14800	C  ONLY ONE - NEEDED FOR RHY.COMPOSITE
14900	1310	IF(INP(ML).NE.1)GO TO 310
15000		VX(JJ+1)=VX(JJ)*2.
15100		JJ=JJ+1
15200		ML=ML+1
15300		GO TO 1310
15400	206	ML=ML+2
15500	3310	VX(1)=-99.
15600	C******** MAY 19,71
15700	310      ISKP=0
15800	        IF(N.NE.ISEMI)GO TO 999
15900	
16000	    	RETURN
16100	73	JJ=JJ+1
16200		 IF(INP(ML).EQ.IE)GO TO 206    
16300	C   NEXT IS FOR A REST ('R')  
16400	      VX(JJ)=85.
16500		GO TO 4410
16600	  	END
16700	
16800		SUBROUTINE BGSORT(BW)
16900	C  THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
17000	C  ALLOWS 100 BG TIMES.
17100		COMMON /Q/ BNW(100),NWZ
17200		DO 5308 K=1,NWZ
17300		X=BNW(K)-.0001
17400		Y=X+.0002
17500	C   ROUND-OFF NONSENSE
17600	5308	IF(BW.GT.X.AND.BW.LT.Y)RETURN
17700		NWZ=NWZ+1
17800		BNW(NWZ)=BW
17900		RETURN
18000		END
18100	
18200		SUBROUTINE FMT(JFM,INP,MLX)
18300		DIMENSION JFM(3),INP(1)
18400		DO 1 MLX=2,72
18500		J=INP(MLX)
18600	1	IF(J.EQ.' '.OR.J.EQ.','.OR.J.EQ.';')GO TO 2
18700	C  SPACE=COMMA=SPACE, ALSO STOPS ON ";"
18800	2	MLX=MLX+1
18900		IF(MLX.GT.7)MLX=7
19000		JFM(2)='0'+(MLX-2)*536870912
19100	C   FINDS NUMBER FOR 'A' FORMAT
19200		RETURN
19300		END
19400	
19500	      SUBROUTINE RANR(VX,K)
19600	C   FOR RAN. SELEC. OF NOTES.  FINDS HIGHEST NOTE.
19700	      DIMENSION VX(1)
19800	      X=VX(K)
19900	      Y=VX(K+1)
20000	      IF(X.GT.Y)VX(K)=X+.999
20100	      IF(Y.GE.X)VX(K+1)=Y+.999
20200	      RETURN
20300	      END
20400	
20500	      SUBROUTINE SQYY(YY,X,Y,Z)
20600	      YY=2.*Z/(X+Y)
20700	      IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
20800	      RETURN
20900	      END
21000	
21100		SUBROUTINE COLTTY(JNP,JT)
21200		COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED /FRMT/J(2)
21300		DIMENSION JNP(1)
21400		DATA J(2)/'72A1)'/
21500		DO 1 K=72,1,-1
21600	1	IF(JNP(K).NE.' ')GO TO 2
21700		K=1
21800	2	IF(JT.EQ.21)GO TO 3
21900		J(1)='  (1X'
22000		IF(LN.EQ.0)GO TO 5
22100		J(1)='(I5,X'
22200		WRITE(JT,J)LN,(JNP(L),L=1,K)
22300		RETURN
22400	3	J(1)='    ('
22500	5	WRITE(JT,J)(JNP(L),L=1,K)
22600		END
22700	
22800		FUNCTION READER(JNP)
22900		DIMENSION JNP(72)
23000		COMMON /TYP/SOS,JOUT,LN,ITYP,TPALN(4),JED
23100		1 /FRMT/J(2)
23200		DATA TPALN/20H(' TYPE A LINE'/)   /
23300		J(1)='    ('
23400		READER=0
23500		IF(ITYP)GO TO 1
23600	6 	TYPE TPALN
23700		ACCEPT J,JNP
23800		IF(JED)CALL COLTTY(JNP,21)
23900		IF(JNP(1).EQ.' ')GO TO 6
24000		RETURN
24100	1	IF(LN.NE.0)GO TO 5
24200		READ(1,J,END=3)JNP
24300		GO TO 7
24400	5	J(1)='  (I,'
24500		READ(1,J,END=3)LN,JNP
24600	7	IF(SOS)CALL COLTTY(JNP,JOUT)
24700		RETURN
24800	3	READER=-1
24900		END
25000	
25100		SUBROUTINE QUAD
25200	C  DUMMY -- FOR NOW.  7/74
25300		END
25400	
25500		FUNCTION RMOVX(W,Y,Z)
25600		IF(W.EQ.0)W=.01
25700		IF(Y.EQ.0)Y=.01
25800		RMOVX=Y*((W/Y)**Z)
25900		END
26000	
28900		SUBROUTINE CLEAN(INP,LEND)
29000		DIMENSION INP(1)
29100	C  CLEAR THE END OF ARRAY
29200		M=72
29300		LEND=-1
29400		K=0
29500	1	K=K+1
29600		NN=INP(K)
29700		IF(NN.EQ.';'.OR.NN.EQ.'/')GO TO 2
29800		IF(NN.EQ.'<')GO TO 3
29900	C  USE < FOR COMMENT--  AS IN MUS10
30000		IF(NN.NE.'"')GO TO 4
30100	7	K=K+1
30200		IF(INP(K).EQ.'"')GO TO 4
30300		IF(K.LT.M)GO TO 7
30400		TYPE 5
30500		STOP
30600	5	FORMAT(' OPEN QUOTES')
30700	2	LEND=K
30800	4	IF(K.LT.M)GO TO 1
30900	3	IF(LEND.GT.0)RETURN
31000		IF(M.EQ.144)CALL EXIT
31100		CALL READER(INP(73))
31200	C  GO READ ANOTHER LINE.
31300		M=144
31400		K=72
31500		GO TO 1
31600		END